COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(DEFMACRO DEFCLASS1 (NAME SUPERCLASSES)
C00011 ENDMK
C⊗;
(DEFMACRO DEFCLASS1 (NAME SUPERCLASSES)
  `(SETF (GET ',NAME 'CLASS-COMPONENTS) ',(REVERSE (CONS NAME SUPERCLASSES))))

;;; Iteration driver
;;; This calls FUNCTION for each component of FLAVOR-NAME at least once.  The arguments
;;; to FUNCTION are the name of the component flavor, the depth of recursion, a list
;;; of the names of all flavors that must locally precede this one (-not- a transitive
;;; closure of the precedence relations!).
;;; If FUNCTION returns NIL, iteration terminates without looking at components to right.
;;; If FUNCTION returns DONT-RECURSE, do younger brothers but not sons.
;;; Undefined components do not cause an error unless FUNCTION does not like them.
;;; The values returned by MAP-COMPONENTS-DEPTH-FIRST are meaningless to the outside caller.
(DEFUN MAP-COMPONENTS-DEPTH-FIRST (FUNCTION FLAVOR-NAME
				   &OPTIONAL (DEPTH 0) (PRECEDENCE NIL) (TRAIL NIL))
  (LET ((CONTINUE (FUNCALL FUNCTION FLAVOR-NAME DEPTH PRECEDENCE))
	(COMPONENTS (GET FLAVOR-NAME 'CLASS-COMPONENTS)))
    (UNLESS (OR (MEMBER CONTINUE '(NIL DONT-RECURSE))
		(MEMBER FLAVOR-NAME TRAIL))	;Break infinite recursion
      (LET ((TRAIL (CONS FLAVOR-NAME TRAIL)))
	;; Use recursion to iterate backwards through list
	(BLOCK RECURSE
	  (LABELS ((ITERATE (COMPONENTS)
		     (WHEN COMPONENTS
		       (LET ((COMPONENT (CAR COMPONENTS)))
			 (UNLESS (EQ COMPONENT FLAVOR-NAME)
			   (ITERATE (CDR COMPONENTS))
			   (UNLESS (MAP-COMPONENTS-DEPTH-FIRST FUNCTION
							       COMPONENT
							       (1+ DEPTH)
							       (CDR COMPONENTS)
							       TRAIL)
			     (RETURN-FROM RECURSE)))))))
	    (ITERATE COMPONENTS)))))
    CONTINUE))

;;; Make alist from component flavor to the components that must be to its left
;;; due to local constraints.  This is -not- the transitive closure of
;;; FLAVOR-LOCAL-COMPONENT-PRECEDENCE, but only the union of it; it's necessary
;;; not to compute the transitive closure here in order for the error reporting
;;; to be able to find cyclic constraints.
(DEFUN MAKE-PRECEDENCE-ALIST (FLAVOR-NAME)
  (LET ((ALIST NIL))
    (MAP-COMPONENTS-DEPTH-FIRST #'(LAMBDA (FLAVOR-NAME DEPTH PRECEDENCE)
				    (DECLARE (IGNORE DEPTH))
				    ;; Construct the union of everything preceding this flavor
				    (LET ((ELEM (ASSOC FLAVOR-NAME ALIST)))
				      (IF ELEM
					  (SETF (CDR ELEM) (UNION (CDR ELEM) PRECEDENCE))
					  (PUSH (CONS FLAVOR-NAME PRECEDENCE) ALIST)))
				    T)
				FLAVOR-NAME)
    (NREVERSE ALIST)))

;;; Compute the FLAVOR-ALL-COMPONENTS list, in the appropriate order.
;;; Check for and explain circular dependencies.
;;; Missing required-flavors and undefined component flavors are detected elsewhere.
(DEFUN COMPOSE-FLAVOR-COMPONENTS (FLAVOR-NAME)
  ;; First combine all the local ordering constraints.
  (LET ((ALIST (MAKE-PRECEDENCE-ALIST FLAVOR-NAME))
	(COMPONENTS NIL) CHANGED SLOW)
    ;; Start with a null components list; the given flavor will always be the first
    ;; component, because it will be the first one encountered by MAP-COMPONENTS-DEPTH-FIRST.
    ;; If there are circular constraints such that the given flavor has to have something
    ;; to its left, this will be detected, because no other flavor is unconstrained.
    ;; Using the local ordering constraints, build an ordered list of components by
    ;; repeated depth-first tree walk until all components have been incorporated that can be.
    ;; The tree walk is done in such an order as to minimize the number of iterations
    ;; through this loop required to come up with the answer.
    ;; SLOW = NIL is an optimization to cut off probably unreachable branches of the tree.
     (SETQ SLOW NIL)
     (LOOP
      (SETQ CHANGED NIL SLOW NIL)
      (MAP-COMPONENTS-DEPTH-FIRST
	#'(LAMBDA (FLAVOR-NAME DEPTH PRECEDENCE)
	    (DECLARE (IGNORE DEPTH PRECEDENCE))
	    (COND ((MEMBER FLAVOR-NAME COMPONENTS) T)	;Already a component, continue
		  ((NOT (ASSOC FLAVOR-NAME ALIST)) 'DONT-RECURSE)  ;Not really a component
		  ((EVERY #'(LAMBDA (PREDECESSOR) (MEMBER PREDECESSOR COMPONENTS))
			  (CDR (ASSOC FLAVOR-NAME ALIST)))
		   ;; This one can go in now, put it in and return T.
		   (PUSH FLAVOR-NAME COMPONENTS)
		   (SETQ CHANGED T))
		  ;; If above LOOP fails, return NIL since everything to right will fail too.
		  ;; But in SLOW mode, disable that optimization.
		  (T SLOW)))
	FLAVOR-NAME)
      (WHEN (NOT CHANGED)
	;; We seem to be done; make sure all components really got incorporated.
	(WHEN (= (LENGTH COMPONENTS) (LENGTH ALIST))
	  (RETURN))
	;; Some components didn't get incorporated.  Either there is an ordering
	;; conflict, or the speedup didn't work.  The speedup fails after recovery
	;; from a conflict, because the constraints are no longer transitive.  It
	;; also fails in the face of partial ordering among the components of a flavor.
	(IF SLOW
	    ;; Already slow: there must be an ordering conflict.
	    ;; Explain it nicely and recover by making an arbitrary choice.
	    (SETQ COMPONENTS (NRECONC (EXPLAIN-COMPONENT-ORDERING-ERROR FLAVOR-NAME ALIST
									COMPONENTS)
				      COMPONENTS))
	    ;; Try again without the speedup.
	    (SETQ SLOW T))))
    ;; Put list of components into normal order
    (NREVERSE COMPONENTS)))